home *** CD-ROM | disk | FTP | other *** search
- /*
- (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
- Copying of this file is authorized to users who have executed the true and
- proper "License Agreement for Kyoto Common LISP" with SIGLISP.
- */
-
- /*
- Arithmetic operations
- */
- #include "include.h"
- #include "num_include.h"
-
- object
- bignum2(most, least)
- int most, least;
- {
- object z;
-
- z = alloc_object(t_bignum);
- vs_push(z);
- z->big.big_car = least;
- z->big.big_cdr = NULL;
- z = (object)(z->big.big_cdr
- = (struct bignum *)alloc_object(t_bignum));
- z->big.big_car = most;
- z->big.big_cdr = NULL;
- return(vs_pop);
- }
-
- object
- bignum3(most, middle, least)
- int most, middle, least;
- {
- object z;
-
- z = alloc_object(t_bignum);
- vs_push(z);
- z->big.big_car = least;
- z->big.big_cdr = NULL;
- z = (object)(z->big.big_cdr
- = (struct bignum *)alloc_object(t_bignum));
- z->big.big_car = middle;
- z->big.big_cdr = NULL;
- z = (object)(z->big.big_cdr
- = (struct bignum *)alloc_object(t_bignum));
- z->big.big_car = most;
- z->big.big_cdr = NULL;
- return(vs_pop);
- }
-
- object
- fixnum_times(i, j)
- int i, j;
- {
-
- int s, h, l;
- object z;
-
- if (i == 0 || j == 0)
- return(small_fixnum(0));
- if (i < 0) {
- if (i == MOST_NEGATIVE_FIX) {
- if (j == MOST_NEGATIVE_FIX)
- return(bignum3(1, 0, 0));
- return(bignum2(-j, 0));
- }
- i = -i;
- s = -1;
- } else
- s = 1;
- if (j < 0) {
- if (j == MOST_NEGATIVE_FIX) {
- if (s < 0)
- return(bignum2(i, 0));
- else
- return(bignum2(-i, 0));
- }
- j = -j;
- s = -s;
- }
- extended_mul(i, j, 0, &h, &l);
- if (h != 0) {
- if (s < 0) {
- if (l == 0)
- if (h == 1)
- return(make_fixnum(
- MOST_NEGATIVE_FIX));
- else
- return(bignum2(-h, 0));
- else
- return(bignum2(~h, (-l) & MASK));
- } else
- return(bignum2(h, l & MASK));
- } else
- return(make_fixnum(s*l));
- }
-
- object
- fix_big_times(i, b)
- int i;
- object b;
- {
- int j, s;
- struct bignum *x;
- vs_mark;
-
- if (i == 1)
- return(b);
- if (i == -1)
- return(number_negate(b));
- x = copy_big(b);
- vs_push((object)x); /* for GC */
- if ((s = big_sign(x)) < 0)
- complement_big(x);
- if (i < 0) {
- if (i == MOST_NEGATIVE_FIX) {
- s = -s;
- x = (struct bignum *)alloc_object(t_bignum);
- x->big_car = 0;
- x->big_cdr = (struct bignum *)(vs_head);
- goto L;
- }
- i = -i;
- s = -s;
- }
- mul_int_big(i, x);
- L:
- if (s < 0)
- complement_big(x);
- x = (struct bignum *)normalize_big_to_object(x);
- vs_reset;
- return((object)x);
- }
-
- object
- big_big_times(x, y)
- object x, y;
- {
- int i, j;
- struct bignum *z;
- vs_mark;
-
- if ((i = big_sign(x)) < 0) {
- x = (object)big_minus(x);
- vs_push(x);
- }
- if ((j = big_sign(y)) < 0) {
- y = (object)big_minus(y);
- vs_push(y);
- }
- z = big_times(x, y);
- vs_push(((object)z));
- if (i > 0 && j < 0 || i < 0 && j > 0)
- complement_big(z);
- z = (struct bignum *)normalize_big_to_object(z);
- vs_reset;
- return((object)z);
- }
-
- object
- number_to_complex(x)
- object x;
- {
- object z;
-
- switch (type_of(x)) {
-
- case t_fixnum:
- case t_bignum:
- case t_ratio:
- case t_shortfloat:
- case t_longfloat:
- z = alloc_object(t_complex);
- z->cmp.cmp_real = x;
- z->cmp.cmp_imag = small_fixnum(0);
- return(z);
-
- case t_complex:
- return(x);
-
- default:
- FEwrong_type_argument(Snumber, x);
- }
- }
-
- object
- number_plus(x, y)
- object x, y;
- {
- int i, j, k;
- double dx, dy;
- object z, z1;
- vs_mark;
-
- switch (type_of(x)) {
-
- case t_fixnum:
- switch(type_of(y)) {
- case t_fixnum:
- if((i = fix(x)) == 0)
- return(y);
- if((j = fix(y)) == 0)
- return(x);
- if(i > 0)
- if (j > 0)
- if ((k = i + j) > 0)
- return(make_fixnum(k));
- else
- return(bignum2(1, k & MASK));
- else
- return(make_fixnum(i + j));
- else
- if(j > 0)
- return(make_fixnum(i + j));
- else
- if ((k = i + j) < 0)
- return(make_fixnum(k));
- else
- return(bignum2(-2, k & MASK));
- case t_bignum:
- if ((i = fix(x)) == 0)
- return(y);
- z = (object)copy_big(y);
- vs_push(z);
- if(i > 0)
- add_int_big(i, z);
- else if (i == MOST_NEGATIVE_FIX)
- sub_int_big(1, z->big.big_cdr);
- else
- sub_int_big(-i, z);
- z = normalize_big_to_object(z);
- vs_reset;
- return(z);
- case t_ratio:
- vs_push(number_times(x, y->rat.rat_den));
- z = number_plus(vs_top[-1], y->rat.rat_num);
- vs_push(z);
- z = make_ratio(z, y->rat.rat_den);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = (double)(fix(x));
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = (double)(fix(x));
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_bignum:
- switch (type_of(y)) {
- case t_fixnum:
- if((j = fix(y)) == 0)
- return(x);
- z = (object)copy_big(x);
- vs_push(z);
- if(j > 0)
- add_int_big(j, z);
- else if (j == MOST_NEGATIVE_FIX)
- sub_int_big(1, z->big.big_cdr);
- else
- sub_int_big(-j, z);
- z = normalize_big_to_object(z);
- vs_reset;
- return(z);
- case t_bignum:
- z = (object)big_plus(x, y);
- vs_push(z);
- z = normalize_big_to_object(z);
- vs_reset;
- return(z);
- case t_ratio:
- vs_push(number_times(x, y->rat.rat_den));
- z = number_plus(vs_top[-1], y->rat.rat_num);
- vs_push(z);
- z = make_ratio(z, y->rat.rat_den);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = number_to_double(x);
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = number_to_double(x);
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_ratio:
- switch (type_of(y)) {
- case t_fixnum:
- case t_bignum:
- vs_push(number_times(x->rat.rat_den, y));
- z = number_plus(x->rat.rat_num, vs_top[-1]);
- vs_push(z);
- z = make_ratio(z, x->rat.rat_den);
- vs_reset;
- return(z);
- case t_ratio:
- vs_push(number_times(x->rat.rat_num,y->rat.rat_den));
- vs_push(number_times(x->rat.rat_den,y->rat.rat_num));
- z = number_plus(vs_top[-2], vs_top[-1]);
- vs_push(z);
- vs_push(number_times(x->rat.rat_den,y->rat.rat_den));
- z = make_ratio(z, vs_top[-1]);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = number_to_double(x);
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = number_to_double(x);
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_shortfloat:
- switch (type_of(y)) {
- case t_fixnum:
- dx = (double)(sf(x));
- dy = (double)(fix(y));
- goto SHORTFLOAT;
- case t_shortfloat:
- dx = (double)(sf(x));
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = (double)(sf(x));
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- dx = (double)(sf(x));
- dy = number_to_double(y);
- goto SHORTFLOAT;
- }
- SHORTFLOAT:
- z = alloc_object(t_shortfloat);
- sf(z) = (shortfloat)(dx + dy);
- return(z);
-
- case t_longfloat:
- dx = lf(x);
- switch (type_of(y)) {
- case t_fixnum:
- dy = (double)(fix(y));
- goto LONGFLOAT;
- case t_shortfloat:
- dy = (double)(sf(y));
- goto LONGFLOAT;
- case t_longfloat:
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- dy = number_to_double(y);
- goto LONGFLOAT;
- }
- LONGFLOAT:
- z = alloc_object(t_longfloat);
- lf(z) = dx + dy;
- return(z);
-
- case t_complex:
- COMPLEX:
- x = number_to_complex(x);
- vs_push(x);
- y = number_to_complex(y);
- vs_push(y);
- vs_push(number_plus(x->cmp.cmp_real, y->cmp.cmp_real));
- vs_push(number_plus(x->cmp.cmp_imag, y->cmp.cmp_imag));
- z = make_complex(vs_top[-2], vs_top[-1]);
- vs_reset;
- return(z);
-
- default:
- FEwrong_type_argument(Snumber, x);
- }
- }
-
- object
- one_plus(x)
- object x;
- {
- int i;
- double dx;
- object z, z1;
- vs_mark;
-
- switch (type_of(x)) {
-
- case t_fixnum:
- i = fix(x);
- if(i == 0)
- return(small_fixnum(1));
- if(i > 0)
- if (++i > 0) {
- if (-SMALL_FIXNUM_LIMIT <= i &&
- i < SMALL_FIXNUM_LIMIT)
- return(small_fixnum(i));
- z = alloc_object(t_fixnum);
- fix(z) = i;
- return(z);
- } else
- return(bignum2(1, i & MASK));
- else {
- i++;
- if (-SMALL_FIXNUM_LIMIT <= i &&
- i < SMALL_FIXNUM_LIMIT)
- return(small_fixnum(i));
- z = alloc_object(t_fixnum);
- fix(z) = i;
- return(z);
- }
-
- case t_bignum:
- return(number_plus(x, small_fixnum(1)));
-
- case t_ratio:
- z = number_plus(x->rat.rat_num, x->rat.rat_den);
- vs_push(z);
- z = make_ratio(z, x->rat.rat_den);
- vs_reset;
- return(z);
-
- case t_shortfloat:
- dx = (double)(sf(x));
- z = alloc_object(t_shortfloat);
- sf(z) = (shortfloat)(dx + 1.0);
- return(z);
-
- case t_longfloat:
- dx = lf(x);
- z = alloc_object(t_longfloat);
- lf(z) = dx + 1.0;
- return(z);
-
- case t_complex:
- COMPLEX:
- vs_push(one_plus(x->cmp.cmp_real));
- z = make_complex(vs_top[-1], x->cmp.cmp_imag);
- vs_reset;
- return(z);
-
- default:
- FEwrong_type_argument(Snumber, x);
- }
- }
-
- object
- number_minus(x, y)
- object x, y;
- {
- int i, j, k;
- double dx, dy;
- object z, z1;
- vs_mark;
-
- switch (type_of(x)) {
-
- case t_fixnum:
- switch(type_of(y)) {
- case t_fixnum:
- if((j = fix(y)) == 0)
- return(x);
- if((i = fix(x)) >= 0)
- if (j < 0)
- if ((k = i - j) > 0)
- return(make_fixnum(k));
- else
- return(bignum2(1, k & MASK));
- else
- return(make_fixnum(i - j));
- else
- if(j < 0)
- return(make_fixnum(i - j));
- else
- if ((k = i - j) < 0)
- return(make_fixnum(k));
- else
- return(bignum2(-2, k & MASK));
- case t_bignum:
- z = (object)big_minus(y);
- vs_push(z);
- if ((i = fix(x)) == 0)
- ;
- else if(i > 0)
- add_int_big(i, z);
- else if (i == MOST_NEGATIVE_FIX)
- sub_int_big(1, z->big.big_cdr);
- else
- sub_int_big(-i, z);
- z = normalize_big_to_object(z);
- vs_reset;
- return(z);
- case t_ratio:
- vs_push(number_times(x, y->rat.rat_den));
- z = number_minus(vs_top[-1], y->rat.rat_num);
- vs_push(z);
- z = make_ratio(z, y->rat.rat_den);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = (double)(fix(x));
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = (double)(fix(x));
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_bignum:
- switch (type_of(y)) {
- case t_fixnum:
- if((j = fix(y)) == 0)
- return(x);
- z = (object)copy_big(x);
- vs_push(z);
- if (j > 0)
- sub_int_big(j, z);
- else if (j == MOST_NEGATIVE_FIX)
- add_int_big(1, z->big.big_cdr);
- else
- add_int_big(-j, z);
- z = normalize_big_to_object(z);
- vs_reset;
- return(z);
- case t_bignum:
- y = (object)big_minus(y);
- vs_push(y);
- z = (object)big_plus(x, y);
- vs_push(z);
- z = normalize_big_to_object(z);
- vs_reset;
- return(z);
- case t_ratio:
- vs_push(number_times(x, y->rat.rat_den));
- z = number_minus(vs_top[-1], y->rat.rat_num);
- vs_push(z);
- z = make_ratio(z, y->rat.rat_den);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = number_to_double(x);
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = number_to_double(x);
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_ratio:
- switch (type_of(y)) {
- case t_fixnum:
- case t_bignum:
- vs_push(number_times(x->rat.rat_den, y));
- z = number_minus(x->rat.rat_num, vs_top[-1]);
- vs_push(z);
- z = make_ratio(z, x->rat.rat_den);
- vs_reset;
- return(z);
- case t_ratio:
- vs_push(number_times(x->rat.rat_num,y->rat.rat_den));
- vs_push(number_times(x->rat.rat_den,y->rat.rat_num));
- z = number_minus(vs_top[-2], vs_top[-1]);
- vs_push(z);
- vs_push(number_times(x->rat.rat_den,y->rat.rat_den));
- z = make_ratio(z, vs_top[-1]);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = number_to_double(x);
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = number_to_double(x);
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_shortfloat:
- switch (type_of(y)) {
- case t_fixnum:
- dx = (double)(sf(x));
- dy = (double)(fix(y));
- goto SHORTFLOAT;
- case t_shortfloat:
- dx = (double)(sf(x));
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = (double)(sf(x));
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- dx = (double)(sf(x));
- dy = number_to_double(y);
- goto SHORTFLOAT;
- }
- SHORTFLOAT:
- z = alloc_object(t_shortfloat);
- sf(z) = (shortfloat)(dx - dy);
- return(z);
-
- case t_longfloat:
- dx = lf(x);
- switch (type_of(y)) {
- case t_fixnum:
- dy = (double)(fix(y));
- goto LONGFLOAT;
- case t_shortfloat:
- dy = (double)(sf(y));
- goto LONGFLOAT;
- case t_longfloat:
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- dy = number_to_double(y);
- }
- LONGFLOAT:
- z = alloc_object(t_longfloat);
- lf(z) = dx - dy;
- return(z);
-
- case t_complex:
- COMPLEX:
- x = number_to_complex(x);
- vs_push(x);
- y = number_to_complex(y);
- vs_push(y);
- vs_push(number_minus(x->cmp.cmp_real, y->cmp.cmp_real));
- vs_push(number_minus(x->cmp.cmp_imag, y->cmp.cmp_imag));
- z = make_complex(vs_top[-2], vs_top[-1]);
- vs_reset;
- return(z);
-
- default:
- FEwrong_type_argument(Snumber, x);
- }
- }
-
- object
- one_minus(x)
- object x;
- {
- int i;
- double dx;
- object z, z1;
- vs_mark;
-
- switch (type_of(x)) {
-
- case t_fixnum:
- i = fix(x);
- if(i == 0)
- return(small_fixnum(-1));
- if(i > 0) {
- i--;
- if (-SMALL_FIXNUM_LIMIT <= i &&
- i < SMALL_FIXNUM_LIMIT)
- return(small_fixnum(i));
- z = alloc_object(t_fixnum);
- fix(z) = i;
- return(z);
- } else
- if (--i < 0) {
- if (-SMALL_FIXNUM_LIMIT <= i &&
- i < SMALL_FIXNUM_LIMIT)
- return(small_fixnum(i));
- z = alloc_object(t_fixnum);
- fix(z) = i;
- return(z);
- } else
- return(bignum2(-2, i & MASK));
-
- case t_bignum:
- return(number_minus(x, small_fixnum(1)));
-
- case t_ratio:
- z = number_minus(x->rat.rat_num, x->rat.rat_den);
- vs_push(z);
- z = make_ratio(z, x->rat.rat_den);
- vs_reset;
- return(z);
-
- case t_shortfloat:
- dx = (double)(sf(x));
- z = alloc_object(t_shortfloat);
- sf(z) = (shortfloat)(dx - 1.0);
- return(z);
-
- case t_longfloat:
- dx = lf(x);
- z = alloc_object(t_longfloat);
- lf(z) = dx - 1.0;
- return(z);
-
- case t_complex:
- COMPLEX:
- vs_push(one_minus(x->cmp.cmp_real));
- z = make_complex(vs_top[-1], x->cmp.cmp_imag);
- vs_reset;
- return(z);
-
- default:
- FEwrong_type_argument(Snumber, x);
- }
- }
-
- object
- number_negate(x)
- object x;
- {
- object z, z1;
- vs_mark;
-
- switch (type_of(x)) {
-
- case t_fixnum:
- if(fix(x) == MOST_NEGATIVE_FIX)
- return(bignum2(1, 0));
- else
- return(make_fixnum(-fix(x)));
-
- case t_bignum:
- z = (object)big_minus(x);
- vs_push(z);
- z = normalize_big_to_object(z);
- vs_reset;
- return(z);
-
- case t_ratio:
- z1 = number_negate(x->rat.rat_num);
- vs_push(z1);
- z = alloc_object(t_ratio);
- z->rat.rat_num = z1;
- z->rat.rat_den = x->rat.rat_den;
- vs_reset;
- return(z);
-
- case t_shortfloat:
- z = alloc_object(t_shortfloat);
- sf(z) = -sf(x);
- return(z);
-
- case t_longfloat:
- z = alloc_object(t_longfloat);
- lf(z) = -lf(x);
- return(z);
-
- case t_complex:
- vs_push(number_negate(x->cmp.cmp_real));
- vs_push(number_negate(x->cmp.cmp_imag));
- z = make_complex(vs_top[-2], vs_top[-1]);
- vs_reset;
- return(z);
-
- default:
- FEwrong_type_argument(Snumber, x);
- }
- }
-
- object
- number_times(x, y)
- object x, y;
- {
- object z;
- double dx, dy;
- vs_mark;
-
- switch (type_of(x)) {
-
- case t_fixnum:
- switch (type_of(y)) {
- case t_fixnum:
- return(fixnum_times(fix(x), fix(y)));
- case t_bignum:
- return(fix_big_times(fix(x), y));
- case t_ratio:
- vs_push(number_times(x, y->rat.rat_num));
- z = make_ratio(vs_top[-1], y->rat.rat_den);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = (double)(fix(x));
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = (double)(fix(x));
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_bignum:
- switch (type_of(y)) {
- case t_fixnum:
- return(fix_big_times(fix(y), x));
- case t_bignum:
- return(big_big_times(x, y));
- case t_ratio:
- vs_push(number_times(x, y->rat.rat_num));
- z = make_ratio(vs_top[-1], y->rat.rat_den);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = number_to_double(x);
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = number_to_double(x);
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_ratio:
- switch (type_of(y)) {
- case t_fixnum:
- case t_bignum:
- vs_push(number_times(x->rat.rat_num, y));
- z = make_ratio(vs_top[-1], x->rat.rat_den);
- vs_reset;
- return(z);
- case t_ratio:
- vs_push(number_times(x->rat.rat_num,y->rat.rat_num));
- vs_push(number_times(x->rat.rat_den,y->rat.rat_den));
- z = make_ratio(vs_top[-2], vs_top[-1]);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = number_to_double(x);
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = number_to_double(x);
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_shortfloat:
- switch (type_of(y)) {
- case t_fixnum:
- dx = (double)(sf(x));
- dy = (double)(fix(y));
- goto SHORTFLOAT;
- case t_shortfloat:
- dx = (double)(sf(x));
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = (double)(sf(x));
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- dx = (double)(sf(x));
- dy = number_to_double(y);
- break;
- }
- SHORTFLOAT:
- z = alloc_object(t_shortfloat);
- sf(z) = (shortfloat)(dx * dy);
- return(z);
-
- case t_longfloat:
- dx = lf(x);
- switch (type_of(y)) {
- case t_fixnum:
- dy = (double)(fix(y));
- goto LONGFLOAT;
- case t_shortfloat:
- dy = (double)(sf(y));
- goto LONGFLOAT;
- case t_longfloat:
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- dy = number_to_double(y);
- }
- LONGFLOAT:
- z = alloc_object(t_longfloat);
- lf(z) = dx * dy;
- return(z);
-
- case t_complex:
- COMPLEX:
- {
- object z1, z2, z11, z12, z21, z22;
-
- x = number_to_complex(x);
- vs_push(x);
- y = number_to_complex(y);
- vs_push(y);
- z11 = number_times(x->cmp.cmp_real, y->cmp.cmp_real);
- vs_push(z11);
- z12 = number_times(x->cmp.cmp_imag, y->cmp.cmp_imag);
- vs_push(z12);
- z21 = number_times(x->cmp.cmp_imag, y->cmp.cmp_real);
- vs_push(z21);
- z22 = number_times(x->cmp.cmp_real, y->cmp.cmp_imag);
- vs_push(z22);
- z1 = number_minus(z11, z12);
- vs_push(z1);
- z2 = number_plus(z21, z22);
- vs_push(z2);
- z = make_complex(z1, z2);
- vs_reset;
- return(z);
- }
-
- default:
- FEwrong_type_argument(Snumber, x);
- }
- }
-
- object
- number_divide(x, y)
- object x, y;
- {
- object z;
- double dx, dy;
- vs_mark;
-
- switch (type_of(x)) {
-
- case t_fixnum:
- case t_bignum:
- switch (type_of(y)) {
- case t_fixnum:
- case t_bignum:
- if(number_zerop(y) == TRUE)
- zero_divisor();
- if (number_minusp(y) == TRUE) {
- x = number_negate(x);
- vs_push(x);
- y = number_negate(y);
- vs_push(y);
- }
- z = make_ratio(x, y);
- vs_reset;
- return(z);
- case t_ratio:
- if(number_zerop(y->rat.rat_num))
- zero_divisor();
- vs_push(number_times(x, y->rat.rat_den));
- z = make_ratio(vs_top[-1], y->rat.rat_num);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = number_to_double(x);
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = number_to_double(x);
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_ratio:
- switch (type_of(y)) {
- case t_fixnum:
- case t_bignum:
- if (number_zerop(y))
- zero_divisor();
- vs_push(number_times(x->rat.rat_den, y));
- z = make_ratio(x->rat.rat_num, vs_top[-1]);
- vs_reset;
- return(z);
- case t_ratio:
- vs_push(number_times(x->rat.rat_num,y->rat.rat_den));
- vs_push(number_times(x->rat.rat_den,y->rat.rat_num));
- z = make_ratio(vs_top[-2], vs_top[-1]);
- vs_reset;
- return(z);
- case t_shortfloat:
- dx = number_to_double(x);
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = number_to_double(x);
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- FEwrong_type_argument(Snumber, y);
- }
-
- case t_shortfloat:
- switch (type_of(y)) {
- case t_fixnum:
- dx = (double)(sf(x));
- dy = (double)(fix(y));
- goto SHORTFLOAT;
- case t_shortfloat:
- dx = (double)(sf(x));
- dy = (double)(sf(y));
- goto SHORTFLOAT;
- case t_longfloat:
- dx = (double)(sf(x));
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- dx = (double)(sf(x));
- dy = number_to_double(y);
- goto LONGFLOAT;
- }
- SHORTFLOAT:
- z = alloc_object(t_shortfloat);
- if (dy == 0.0)
- zero_divisor();
- sf(z) = (shortfloat)(dx / dy);
- return(z);
-
-
- case t_longfloat:
- dx = lf(x);
- switch (type_of(y)) {
- case t_fixnum:
- dy = (double)(fix(y));
- goto LONGFLOAT;
- case t_shortfloat:
- dy = (double)(sf(y));
- goto LONGFLOAT;
- case t_longfloat:
- dy = lf(y);
- goto LONGFLOAT;
- case t_complex:
- goto COMPLEX;
- default:
- dy = number_to_double(y);
- }
- LONGFLOAT:
- z = alloc_object(t_longfloat);
- if (dy == 0.0)
- zero_divisor();
- lf(z) = dx / dy;
- return(z);
-
- case t_complex:
- COMPLEX:
- {
- object z1, z2, z3;
-
- x = number_to_complex(x);
- vs_push(x);
- y = number_to_complex(y);
- vs_push(y);
- z1 = number_times(y->cmp.cmp_real, y->cmp.cmp_real);
- vs_push(z1);
- z2 = number_times(y->cmp.cmp_imag, y->cmp.cmp_imag);
- vs_push(z2);
- if (number_zerop(z3 = number_plus(z1, z2)))
- zero_divisor();
- vs_push(z3);
- z1 = number_times(x->cmp.cmp_real, y->cmp.cmp_real);
- vs_push(z1);
- z2 = number_times(x->cmp.cmp_imag, y->cmp.cmp_imag);
- vs_push(z2);
- z1 = number_plus(z1, z2);
- vs_push(z1);
- z = number_times(x->cmp.cmp_imag, y->cmp.cmp_real);
- vs_push(z);
- z2 = number_times(x->cmp.cmp_real, y->cmp.cmp_imag);
- vs_push(z2);
- z2 = number_minus(z, z2);
- vs_push(z2);
- z1 = number_divide(z1, z3);
- vs_push(z1);
- z2 = number_divide(z2, z3);
- vs_push(z2);
- z = make_complex(z1, z2);
- vs_reset;
- return(z);
- }
-
- default:
- FEwrong_type_argument(Snumber, x);
- }
- }
-
- integer_quotient_remainder_1(x, y, qp, rp)
- object x, y;
- object *qp, *rp;
- {
- enum type tx, ty;
- int i, j, q, r;
- vs_mark;
-
- tx = type_of(x);
- ty = type_of(y);
- if (tx == t_fixnum) {
- if (ty == t_fixnum) {
- if (fix(y) == 0)
- zero_divisor();
- if (fix(y) == MOST_NEGATIVE_FIX)
- if (fix(x) == MOST_NEGATIVE_FIX) {
- *qp = small_fixnum(1);
- *rp = small_fixnum(0);
- return;
- } else {
- *qp = small_fixnum(0);
- *rp = x;
- return;
- }
- if (fix(x) == MOST_NEGATIVE_FIX) {
- if (fix(y) == 1) {
- *qp = x;
- *rp = small_fixnum(0);
- return;
- }
- if (fix(y) == -1) {
- *qp = bignum2(1, 0);
- *rp = small_fixnum(0);
- return;
- }
- if (fix(y) > 0) {
- extended_div(fix(y), 1, 0,
- &q, &r);
- *qp = make_fixnum(-q);
- vs_push(*qp);
- *rp = make_fixnum(-r);
- vs_reset;
- return;
- } else {
- extended_div(-fix(y), 1, 0,
- &q, &r);
- *qp = make_fixnum(q);
- vs_push(*qp);
- *rp = make_fixnum(-r);
- vs_reset;
- return;
- }
- }
- *qp = make_fixnum(fix(x) / fix(y));
- vs_push(*qp);
- *rp = make_fixnum(fix(x) % fix(y));
- vs_reset;
- return;
- }
- if (ty == t_bignum) {
- if (fix(x) == MOST_NEGATIVE_FIX &&
- y->big.big_car == 0 &&
- y->big.big_cdr->big_car == 1 &&
- y->big.big_cdr->big_cdr == NULL) {
- *qp = small_fixnum(-1);
- *rp = small_fixnum(0);
- return;
- }
- *qp = small_fixnum(0);
- *rp = x;
- return;
- } else
- FEwrong_type_argument(Sinteger, y);
- }
- if (tx == t_bignum) {
- if (ty == t_fixnum) {
- if (fix(y) == 0)
- zero_divisor();
- x = (object)copy_big(x);
- vs_push(x);
- if((i = big_sign(x)) < 0) {
- complement_big(x);
- }
- if (fix(y) == MOST_NEGATIVE_FIX) {
- j = -i;
- if (x->big.big_cdr == NULL) {
- stretch_big(x, 0);
- }
- if (i < 0)
- *rp =
- make_fixnum(-x->big.big_car);
- else
- *rp =
- make_fixnum(x->big.big_car);
- vs_push(*rp);
- x = (object)(x->big.big_cdr);
- if (j < 0)
- complement_big(x);
- *qp=normalize_big_to_object(x);
- vs_reset;
- return;
- }
- if (fix(y) < 0) {
- q = -fix(y);
- j = -i;
- } else {
- q = fix(y);
- j = i;
- }
- r = div_int_big(q, x);
- if (j < 0) {
- complement_big(x);
- }
- *qp = normalize_big_to_object(x);
- vs_push(*qp);
- *rp = make_fixnum(i < 0 ? -r : r);
- vs_reset;
- return;
- }
- else if (ty == t_bignum) {
- if ((i = big_sign(x)) < 0) {
- x = (object)big_minus(x);
- vs_push(x);
- }
- if (big_sign(y) < 0) {
- y = (object)big_minus(y);
- vs_push(y);
- j = -i;
- } else
- j = i;
- big_quotient_remainder(x, y, qp, rp);
- vs_push(*qp);
- vs_push(*rp);
- if (j < 0) {
- complement_big(*qp);
- }
- if (i < 0) {
- complement_big(*rp);
- }
- *qp = normalize_big_to_object(*qp);
- vs_push(*qp);
- *rp = normalize_big_to_object(*rp);
- vs_reset;
- return;
- }
- else
- FEwrong_type_argument(Sinteger, y);
- }
- FEwrong_type_argument(Sinteger, y);
- }
-
- object
- integer_divide1(x, y)
- object x, y;
- {
- object q, r;
-
- integer_quotient_remainder_1(x, y, &q, &r);
- return(q);
- }
-
- object
- get_gcd(x, y)
- object x, y;
- {
- int i, j, k;
- object q, r;
- vs_mark;
-
- if (number_minusp(x))
- x = number_negate(x);
- vs_push(x);
- if (number_minusp(y))
- y = number_negate(y);
- vs_push(y);
-
- L:
- if (type_of(x) == t_fixnum && type_of(y) == t_fixnum) {
- i = fix(x);
- j = fix(y);
- LL:
- if (i < j) {
- k = i;
- i = j;
- j = k;
- }
- if (j == 0) {
- vs_reset;
- return(make_fixnum(i));
- }
- k = i % j;
- i = j;
- j = k;
- goto LL;
- }
-
- if (number_compare(x, y) < 0) {
- r = x;
- x = y;
- y = r;
- }
- if (type_of(y) == t_fixnum && fix(y) == 0) {
- vs_reset;
- return(x);
- }
- integer_quotient_remainder_1(x, y, &q, &r);
- vs_top[-2] = x = y;
- vs_top[-1] = y = r;
- goto L;
- }
-
- /* (+ ) */
- Lplus()
- {
- int i, j;
-
- j = vs_top - vs_base;
- if (j == 0) {
- vs_push(small_fixnum(0));
- return;
- }
- for (i = 0; i < j; i++)
- check_type_number(&vs_base[i]);
- for (i = 1; i < j; i++)
- vs_base[0] = number_plus(vs_base[0], vs_base[i]);
- vs_top = vs_base+1;
- }
-
- Lminus()
- {
- int i, j;
-
- j = vs_top - vs_base;
- if (j == 0)
- too_few_arguments();
- for (i = 0; i < j ; i++)
- check_type_number(&vs_base[i]);
- if (j == 1) {
- vs_base[0] = number_negate(vs_base[0]);
- return;
- }
- for (i = 1; i < j; i++)
- vs_base[0] = number_minus(vs_base[0], vs_base[i]);
- vs_top = vs_base+1;
- }
-
- Ltimes()
- {
- int i, j;
-
- j = vs_top - vs_base;
- if (j == 0) {
- vs_push(small_fixnum(1));
- return;
- }
- for (i = 0; i < j; i++)
- check_type_number(&vs_base[i]);
- for (i = 1; i < j; i++)
- vs_base[0] = number_times(vs_base[0], vs_base[i]);
- vs_top = vs_base+1;
- }
-
- Ldivide()
- {
- int i, j;
-
- j = vs_top - vs_base;
- if (j == 0)
- too_few_arguments();
- for(i = 0; i < j; i++)
- check_type_number(&vs_base[i]);
- if (j == 1) {
- vs_base[0] = number_divide(small_fixnum(1), vs_base[0]);
- return;
- }
- for (i = 1; i < j; i++)
- vs_base[0] = number_divide(vs_base[0], vs_base[i]);
- vs_top = vs_base+1;
- }
-
- Lone_plus()
- {
- object x;
-
- check_arg(1);
- check_type_number(&vs_base[0]);
- vs_base[0] = one_plus(vs_base[0]);
- }
-
- Lone_minus()
- {
- object x;
-
- check_arg(1);
- check_type_number(&vs_base[0]);
- vs_base[0] = one_minus(vs_base[0]);
- }
-
- Lconjugate()
- {
- object c, i;
-
- check_arg(1);
- check_type_number(&vs_base[0]);
- c = vs_base[0];
- if (type_of(c) == t_complex) {
- i = number_negate(c->cmp.cmp_imag);
- vs_push(i);
- vs_base[0] = make_complex(c->cmp.cmp_real, i);
- vs_pop;
- }
- }
-
- Lgcd()
- {
- int i, narg;
-
- narg = vs_top - vs_base;
- if (narg == 0) {
- vs_push(small_fixnum(0));
- return;
- }
- for (i = 0; i < narg; i++)
- check_type_integer(&vs_base[i]);
- if (narg == 1) {
- if (number_minusp(vs_base[0]))
- vs_base[0] = number_negate(vs_base[0]);
- return;
- }
- for (i = 1; i < narg; i++)
- vs_base[0] = get_gcd(vs_base[0], vs_base[i]);
- vs_top = vs_base+1;
- }
-
- Llcm()
- {
- object t, g;
- int i, narg;
-
- narg = vs_top - vs_base;
- if (narg == 0)
- too_few_arguments();
- for (i = 0; i < narg; i++)
- check_type_integer(&vs_base[i]);
- if (narg == 1) {
- if (number_minusp(vs_base[0]))
- vs_base[0] = number_negate(vs_base[0]);
- return;
- }
- for (i = 1; i < narg; i++) {
- t = number_times(vs_base[0], vs_base[i]);
- vs_push(t);
- g = get_gcd(vs_base[0], vs_base[i]);
- vs_push(g);
- vs_base[0] = number_divide(t, g);
- vs_pop;
- vs_pop;
- }
- if (number_minusp(vs_base[0]))
- vs_base[0] = number_negate(vs_base[0]);
- vs_top = vs_base+1;
- }
-
- zero_divisor()
- {
- FEerror("Zero divisor.", 0);
- }
-
- init_num_arith()
- {
- make_function("+", Lplus);
- make_function("-", Lminus);
- make_function("*", Ltimes);
- make_function("/", Ldivide);
- make_function("1+", Lone_plus);
- make_function("1-", Lone_minus);
- make_function("CONJUGATE", Lconjugate);
- make_function("GCD", Lgcd);
- make_function("LCM", Llcm);
- }
-